Option Explicit
Dim CRligDebut As Long
Dim CRligFin As Long
Dim CRcolDebut As Long
Dim CRcolFin As Long

Sub AdressesCurrentRegion(Feuille As Worksheet, CelluleDebut As String)
    'Utilise ligDebut, ligFin, colDebut, colFin
    Dim i As Integer, s As String, t As String
    Dim lig As Long, col As Long
    Dim email As String, Coordonnees As String
    
    Feuille.Activate
    Feuille.Range(CelluleDebut).Select
    Coordonnees = Selection.CurrentRegion.Address
    'MsgBox Coordonnees
    lig = InStr(2, Coordonnees, "$")
    s = Mid(Coordonnees, 2, lig - 2)
    CRcolDebut = 0
    For i = 1 To Len(s)
        CRcolDebut = CRcolDebut * 26
        t = Mid(s, i, 1)
        CRcolDebut = CRcolDebut + Asc(t) - Asc("A") + 1
    Next
    col = lig + 1
    lig = InStr(col, Coordonnees, ":")
    CRligDebut = CLng(Mid(Coordonnees, col, lig - col))
    col = lig + 2
    lig = InStr(col, Coordonnees, "$")
    s = Mid(Coordonnees, col, lig - col)
    CRcolFin = 0
    For i = 1 To Len(s)
        CRcolFin = CRcolFin * 26
        t = Mid(s, i, 1)
        CRcolFin = CRcolFin + Asc(t) - Asc("A") + 1
    Next
    col = lig + 1
    CRligFin = CLng(Mid(Coordonnees, col))
    'MsgBox CRligDebut & " " & CRcolDebut & " " & CRligFin & " " & CRcolFin
End Sub

Function nToColonneExcel(n As Long) As String
    Dim r As Long, q As Long, col As String
    r = n Mod 26
    q = n \ 26
    If r = 0 Then
        r = 26
        q = q - 1
    End If
    col = Chr(r + Asc("@"))
    If q <> 0 Then col = Chr(q + Asc("@")) & col
    nToColonneExcel = col
End Function

'Cellule G2=SI(C2="AGW";1;0)+SI(D2="CAD";1;0)+SI(E2="INF";1;0)
'Cellule H2=SI(F2="OTHERS";1;0)
'Cellule H2=SI(F2="OTHRFC";1;0)
'Cellule I2=SI(ET(G2<>0;H2<>0);1;0)
'Cellule J2=SI(I2=1;"XXXXXX";"")

Sub Fusionner()
' !!! Chaque feuille d'adresses d'email doit être triée en ordre croissant avant de commencer !!!
'Réunit plusieurs feuilles d'adresses d'email sur une feuille appelée "Fusion".
'La feuille "Fusion" doit être créée avant de commencer.
'La procédure suppose que toutes les feuilles d'adresses ont la même structure ou
'   du moins que les colonnes à copier sont au même endroit dans toutes les feuilles
'Dans la feuille de fusion, la procédure ajoute le nom des feuilles où elle a
'   trouvé les adresses qu'elle a fusionnées
    Const MaxFeuilles = 10
    Dim ListeFeuilles(MaxFeuilles) As String
    Dim ListeSheets(MaxFeuilles) As Excel.Worksheet
    Dim ligDebut(MaxFeuilles) As Long
    Dim ligFin(MaxFeuilles) As Long
    Dim colDebut(MaxFeuilles) As Long
    Dim colFin(MaxFeuilles) As Long
    Dim ptrLigne(MaxFeuilles) As Long
    Dim email(MaxFeuilles) As String
    Dim marqueColonne(MaxFeuilles) As Long
    Dim colonneDebutMarquePage As Long
    Dim nbFeuilles As Integer
    
    Dim Colonnes(10) As String
    Dim NumColonnes(10) As Long
    Dim nbColonnes As Long, colFeuille As Long
    Dim i As Integer, j As Integer, fini As Boolean, cptDriveFini As Integer
    Dim lastEmail As String, numFiche As String, temp As String, drive As Integer
    
    Dim PremFormCol As Long     'N° de la première colonne de formules
'!!! Ces variables n'ont servi que dans un contexte particulier : le cas où on ajoute des calcul à la fin. On peut le supprimer !!!
    Dim FormCol As Long         'N° de la colonne où doit être rangée la formule
    Dim strCol As String        'N° de colonne transformée en lettres
    Dim Formule As String       'Formule à ranger dans la cellule
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
    
'Définit les noms et le numéro des colonnes à copier
    nbColonnes = 2
    Colonnes(1) = "Num Fiche"
    NumColonnes(1) = 1
    Colonnes(2) = "Mail"
    NumColonnes(2) = 2
    Const COLMAIL = 2
    
'Définit les noms des feuilles à fusionner.
'   la dernière feuille est la feuille de fusion
    nbFeuilles = 4	'Nombre de feuilles à fusionner
    colonneDebutMarquePage = nbColonnes + 1
    PremFormCol = colonneDebutMarquePage + nbFeuilles
    ListeFeuilles(0) = "AGW"
    ListeFeuilles(1) = "CAD"
    ListeFeuilles(2) = "INF"
    ListeFeuilles(3) = "OTHRFC"
    ListeFeuilles(nbFeuilles) = "Fusion"
    For i = 0 To nbFeuilles
        On Error GoTo ErreurAbsenceFeuille
        Set ListeSheets(i) = ActiveWorkbook.Sheets(ListeFeuilles(i))
        On Error GoTo 0
        If i < nbFeuilles Then  'Cas des feuilles à fusionner
            AdressesCurrentRegion ListeSheets(i), "A1"
            ligDebut(i) = CRligDebut
            ligFin(i) = CRligFin
            colDebut(i) = CRcolDebut
            colFin(i) = CRcolFin
            'marqueColonne est le numéro de la colonne dans laquelle la procédure doit
            '  stocker le nom de la feuille dans laquelle l'adresse a été trouvée
            'On utilisera une colonne différente par feuille.
            '  sinon, si une adresse se trouve dans plusieurs feuille, cela s'écraserait
            marqueColonne(i) = i + colonneDebutMarquePage
            ptrLigne(i) = 2 'initialise le compteur de lignes
            email(i) = LCase(ListeSheets(i).Cells(2, NumColonnes(COLMAIL)).Value)
        Else    'Cas de la feuille de fusion
            ListeSheets(i).Cells.Clear
            For j = 1 To nbColonnes
                ListeSheets(i).Cells(1, NumColonnes(j)).Value = Colonnes(j)
            Next
            For j = 0 To nbFeuilles - 1
                ListeSheets(i).Cells(1, marqueColonne(j)).Value = "Col_" & ListeFeuilles(j)
            Next
            ptrLigne(i) = 2 'initialise le compteur de lignes
        End If
    Next
    
    fini = False
    lastEmail = "zzzzzzzzzzzzzzzzzz"
    Do While Not fini
        cptDriveFini = 0
        temp = "zzzzzzzzzzzzzzzzzzz"
        For i = 0 To nbFeuilles - 1
        'Recherche à chaque itération, quelle est l'adresse la plus petite
            If ptrLigne(i) <> 0 Then    'ptrLigne à 0 = la liste est arrivée au bout
                If StrComp(email(i), temp, vbTextCompare) < 0 Then
                    drive = i   'drive représente le numéro de la feuille qui va être fusionnée
                    temp = email(i)
                End If
            Else
                cptDriveFini = cptDriveFini + 1
            End If
        Next
        If cptDriveFini = nbFeuilles Then   'Si toutes le listes sont arrivées au bout = terminé
            fini = True
            Exit Do
        End If
        If email(drive) = lastEmail Then    'Si l'adresse à fusionner est identique à la précédente = l'ignorer
            ' mais stocker le nom de la feuille où elle a été trouvée
            ListeSheets(nbFeuilles).Cells(ptrLigne(nbFeuilles) - 1, marqueColonne(drive)).Value = ListeFeuilles(drive)
        Else
            lastEmail = email(drive)    'Mémorise la dernière adresse fusionnée
            For j = 1 To nbColonnes 'Fusionne toutes les colonnes
                'Fusionne les colonnes de la feuille d'origine vers la feuille de fusion
                ListeSheets(nbFeuilles).Cells(ptrLigne(nbFeuilles), NumColonnes(j)).Value = ListeSheets(drive).Cells(ptrLigne(drive), NumColonnes(j)).Value
                'Ajoute le nom de la feuille où l'adresse a été trouvée
                ListeSheets(nbFeuilles).Cells(ptrLigne(nbFeuilles), marqueColonne(drive)).Value = ListeFeuilles(drive)
            Next

            'Ajoute les formules de calcul des statistiques sur la ligne 2 des la feuille Fusion
'!!! Ces calculs n'ont servi que dans un contexte particulier. Ils peuvent être supprimés ou réécris pour vos besoins !!!
            If ptrLigne(nbFeuilles) = 2 Then
                FormCol = PremFormCol
                strCol = nToColonneExcel(FormCol)
                'Cellule G2=SI(C2="AGW";1;0)+SI(D2="CAD";1;0)+SI(E2="INF";1;0)
                Formule = "="
                For j = 0 To nbFeuilles - 2
                    Formule = Formule & "IF(RC[" & CStr(marqueColonne(j) - FormCol) & "]=""" & ListeFeuilles(j) & """,1,0)"
                    If j < nbFeuilles - 2 Then
                        Formule = Formule & "+"
                    End If
                Next
                ListeSheets(nbFeuilles).Range(strCol & "2").FormulaR1C1 = Formule
                
                'Cellule H2=SI(F2="OTHERS";1;0)
                FormCol = FormCol + 1
                strCol = nToColonneExcel(FormCol)
                Formule = "=IF(RC[" & CStr(marqueColonne(nbFeuilles - 1) - FormCol) & "]=""" & ListeFeuilles(nbFeuilles - 1) & """,1,0)"
                ListeSheets(nbFeuilles).Range(strCol & "2").FormulaR1C1 = Formule
                
                'Cellule I2=SI(ET(G2<>0;H2<>0);1;0)
                FormCol = FormCol + 1
                strCol = nToColonneExcel(FormCol)
                Formule = "=IF(AND(RC[-2]<>0,RC[-1]<>0),1,0)"
                ListeSheets(nbFeuilles).Range(strCol & "2").FormulaR1C1 = Formule
                
                'Cellule J2=SI(I2=1;"XXXXXX";"")
                FormCol = FormCol + 1
                strCol = nToColonneExcel(FormCol)
                Formule = "=IF(RC[-1]=1,""XXXXXX"","""")"
                ListeSheets(nbFeuilles).Range(strCol & "2").FormulaR1C1 = Formule
            End If
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            ptrLigne(nbFeuilles) = ptrLigne(nbFeuilles) + 1
        End If

        'Cherche l'adresse suivante dans la feuille d'origine de l'adreese qui vient d'être fusionnée
        ptrLigne(drive) = ptrLigne(drive) + 1
        If ptrLigne(drive) > ligFin(drive) Then
            ptrLigne(drive) = 0
        Else
            email(drive) = LCase(ListeSheets(drive).Cells(ptrLigne(drive), NumColonnes(COLMAIL)).Value)
        End If
    Loop
    
    'Etend les calculs des statistiques sur toute la feuille Fusion
'!!! Ces calculs n'ont servi que dans un contexte particulier. Ils peuvent être supprimés ou réécrits selon vos besoins !!!
    strCol = nToColonneExcel(PremFormCol)
    Formule = nToColonneExcel(PremFormCol + 3)
    ListeSheets(nbFeuilles).Select
    Range(strCol & "2" & ":" & Formule & "2").Select
    Selection.AutoFill Destination:=Range(strCol & "2" & ":" & Formule & CStr(ptrLigne(nbFeuilles) - 1)), Type:=xlFillDefault
    'Convertit les calculs en valeurs
    Range(strCol & "2" & ":" & Formule & CStr(ptrLigne(nbFeuilles) - 1)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    'Fait la somme de chaque colonne de calculs
    FormCol = PremFormCol
    strCol = nToColonneExcel(FormCol)
    Range(strCol & CStr(ptrLigne(nbFeuilles))).Select
    Selection.FormulaR1C1 = "=SUM(R[" & CStr(2 - ptrLigne(nbFeuilles)) & "]C:R[-1]C)"
    FormCol = FormCol + 1
    strCol = nToColonneExcel(FormCol)
    Range(strCol & CStr(ptrLigne(nbFeuilles))).Select
    Selection.FormulaR1C1 = "=SUM(R[" & CStr(2 - ptrLigne(nbFeuilles)) & "]C:R[-1]C)"
    FormCol = FormCol + 1
    strCol = nToColonneExcel(FormCol)
    Range(strCol & CStr(ptrLigne(nbFeuilles))).Select
    Selection.FormulaR1C1 = "=SUM(R[" & CStr(2 - ptrLigne(nbFeuilles)) & "]C:R[-1]C)"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    
    
    'Désalocate les objets créés
    MsgBox "Travail terminé"
Sortir:
    For i = 0 To nbFeuilles
        Set ListeSheets(i) = Nothing
    Next
    Exit Sub
ErreurAbsenceFeuille:
    MsgBox "La feuille '" & ListeFeuilles(i) & "' n'existe pas"
    Resume Sortir
End Sub